home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlstruct.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  12.6 KB  |  474 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlstruct.c
  5. * RCS:          $Header: xlstruct.c,v 1.4 91/03/24 22:25:29 mayer Exp $
  6. * Description:  the defstruct facility
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:11:37 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlstruct.c,v 1.4 91/03/24 22:25:29 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* external variables */
  48. extern LVAL xlenv,xlfenv;
  49. extern LVAL s_lambda,s_quote,lk_key,true;
  50. extern char buf[];
  51.  
  52. /* local variables */
  53. static prefix[STRMAX+1];
  54.  
  55. /* xmkstruct - the '%make-struct' function */
  56. LVAL xmkstruct()
  57. {
  58.     LVAL type,val;
  59.     int i;
  60.  
  61.     /* get the structure type */
  62.     type = xlgasymbol();
  63.  
  64.     /* make the structure */
  65.     val = newstruct(type,xlargc);
  66.  
  67.     /* store each argument */
  68.     for (i = 1; moreargs(); ++i)
  69.     setelement(val,i,nextarg());
  70.     xllastarg();
  71.  
  72.     /* return the structure */
  73.     return (val);
  74. }
  75.  
  76. /* xcpystruct - the '%copy-struct' function */
  77. LVAL xcpystruct()
  78. {
  79.     LVAL str,val;
  80.     int size,i;
  81.     str = xlgastruct();
  82.     xllastarg();
  83.     size = getsize(str);
  84.     val = newstruct(getelement(str,0),size-1);
  85.     for (i = 1; i < size; ++i)
  86.     setelement(val,i,getelement(str,i));
  87.     return (val);
  88. }
  89.  
  90. /* xstrref - the '%struct-ref' function */
  91. LVAL xstrref()
  92. {
  93.     LVAL str,val;
  94.     int i;
  95.     str = xlgastruct();
  96.     val = xlgafixnum(); i = (int)getfixnum(val);
  97.     xllastarg();
  98.     return (getelement(str,i));
  99. }
  100.  
  101. /* xstrset - the '%struct-set' function */
  102. LVAL xstrset()
  103. {
  104.     LVAL str,val;
  105.     int i;
  106.     str = xlgastruct();
  107.     val = xlgafixnum(); i = (int)getfixnum(val);
  108.     val = xlgetarg();
  109.     xllastarg();
  110.     setelement(str,i,val);
  111.     return (val);
  112. }
  113.  
  114. /* xstrtypep - the '%struct-type-p' function */
  115. LVAL xstrtypep()
  116. {
  117.     LVAL type,val;
  118.     type = xlgasymbol();
  119.     val = xlgetarg();
  120.     xllastarg();
  121.     return (structp(val) && getelement(val,0) == type ? true : NIL);
  122. }
  123.  
  124. /* xdefstruct - the 'defstruct' special form */
  125. LVAL xdefstruct()
  126. {
  127.     LVAL structname,slotname,defexpr,sym,tmp,args,body;
  128.     LVAL options,oargs,slots;
  129.     char *pname;
  130.     int slotn;
  131.     
  132.     /* protect some pointers */
  133.     xlstkcheck(6);
  134.     xlsave(structname);
  135.     xlsave(slotname);
  136.     xlsave(defexpr);
  137.     xlsave(args);
  138.     xlsave(body);
  139.     xlsave(tmp);
  140.     
  141.     /* initialize */
  142.     args = body = NIL;
  143.     slotn = 0;
  144.  
  145.     /* get the structure name */
  146.     tmp = xlgetarg();
  147.     if (symbolp(tmp)) {
  148.     structname = tmp;
  149.     strcpy(prefix,getstring(getpname(structname)));
  150.     strcat(prefix,"-");
  151.     }
  152.  
  153.     /* get the structure name and options */
  154.     else if (consp(tmp) && symbolp(car(tmp))) {
  155.     structname = car(tmp);
  156.     strcpy(prefix,getstring(getpname(structname)));
  157.     strcat(prefix,"-");
  158.  
  159.     /* handle the list of options */
  160.     for (options = cdr(tmp); consp(options); options = cdr(options)) {
  161.  
  162.         /* get the next argument */
  163.         tmp = car(options);
  164.         
  165.         /* handle options that don't take arguments */
  166.         if (symbolp(tmp)) {
  167.         pname = (char *) getstring(getpname(tmp));
  168.         xlerror("unknown option",tmp);
  169.         }
  170.  
  171.         /* handle options that take arguments */
  172.         else if (consp(tmp) && symbolp(car(tmp))) {
  173.         pname = (char *) getstring(getpname(car(tmp)));
  174.         oargs = cdr(tmp);
  175.  
  176.         /* check for the :CONC-NAME keyword */
  177.         if (strcmp(pname,":CONC-NAME") == 0) {
  178.  
  179.             /* get the name of the structure to include */
  180.             if (!consp(oargs) || !symbolp(car(oargs)))
  181.             xlerror("expecting a symbol",oargs);
  182.  
  183.             /* save the prefix */
  184.             strcpy(prefix,getstring(getpname(car(oargs))));
  185.         }
  186.  
  187.         /* check for the :INCLUDE keyword */
  188.         else if (strcmp(pname,":INCLUDE") == 0) {
  189.  
  190.             /* get the name of the structure to include */
  191.             if (!consp(oargs) || !symbolp(car(oargs)))
  192.             xlerror("expecting a structure name",oargs);
  193.             tmp = car(oargs);
  194.             oargs = cdr(oargs);
  195.  
  196.             /* add each slot from the included structure */
  197.             slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
  198.             for (; consp(slots); slots = cdr(slots)) {
  199.             if (consp(car(slots)) && consp(cdr(car(slots)))) {
  200.  
  201.                 /* get the next slot description */
  202.                 tmp = car(slots);
  203.  
  204.                 /* create the slot access functions */
  205.                 addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
  206.             }
  207.             }
  208.  
  209.             /* handle slot initialization overrides */
  210.             for (; consp(oargs); oargs = cdr(oargs)) {
  211.             tmp = car(oargs);
  212.             if (symbolp(tmp)) {
  213.                 slotname = tmp;
  214.                 defexpr = NIL;
  215.             }
  216.             else if (consp(tmp) && symbolp(car(tmp))) {
  217.                 slotname = car(tmp);
  218.                 defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  219.             }
  220.             else
  221.                 xlerror("bad slot description",tmp);
  222.             updateslot(args,slotname,defexpr);
  223.             }
  224.         }
  225.         else
  226.             xlerror("unknown option",tmp);
  227.         }
  228.         else
  229.         xlerror("bad option syntax",tmp);
  230.     }
  231.     }
  232.  
  233.     /* get each of the structure members */
  234.     while (moreargs()) {
  235.     
  236.     /* get the slot name and default value expression */
  237.     tmp = xlgetarg();
  238.     if (symbolp(tmp)) {
  239.         slotname = tmp;
  240.         defexpr = NIL;
  241.     }
  242.     else if (consp(tmp) && symbolp(car(tmp))) {
  243.         slotname = car(tmp);
  244.         defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  245.     }
  246.     else
  247.         xlerror("bad slot description",tmp);
  248.     
  249.     /* create a closure for non-trival default expressions */
  250.     if (defexpr != NIL) {
  251.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  252.         setbody(tmp,cons(defexpr,NIL));
  253.         tmp = cons(tmp,NIL);
  254.         defexpr = tmp;
  255.     }
  256.  
  257.     /* create the slot access functions */
  258.     addslot(slotname,defexpr,++slotn,&args,&body);
  259.     }
  260.     
  261.     /* store the slotnames and default expressions */
  262.     xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
  263.  
  264.     /* enter the MAKE-xxx symbol */
  265.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  266.     sym = xlenter(buf);
  267.  
  268.     /* make the MAKE-xxx function */
  269.     args = cons(lk_key,args);
  270.     tmp = cons(structname,NIL);
  271.     tmp = cons(s_quote,tmp);
  272.     body = cons(tmp,body);
  273.     body = cons(xlenter("%MAKE-STRUCT"),body);
  274.     body = cons(body,NIL);
  275.     setfunction(sym,
  276.         xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
  277.  
  278.     /* enter the xxx-P symbol */
  279.     sprintf(buf,"%s-P",getstring(getpname(structname)));
  280.     sym = xlenter(buf);
  281.  
  282.     /* make the xxx-P function */
  283.     args = cons(xlenter("X"),NIL);
  284.     body = cons(xlenter("X"),NIL);
  285.     tmp = cons(structname,NIL);
  286.     tmp = cons(s_quote,tmp);
  287.     body = cons(tmp,body);
  288.     body = cons(xlenter("%STRUCT-TYPE-P"),body);
  289.     body = cons(body,NIL);
  290.     setfunction(sym,
  291.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  292.  
  293.     /* enter the COPY-xxx symbol */
  294.     sprintf(buf,"COPY-%s",getstring(getpname(structname)));
  295.     sym = xlenter(buf);
  296.  
  297.     /* make the COPY-xxx function */
  298.     args = cons(xlenter("X"),NIL);
  299.     body = cons(xlenter("X"),NIL);
  300.     body = cons(xlenter("%COPY-STRUCT"),body);
  301.     body = cons(body,NIL);
  302.     setfunction(sym,
  303.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  304.  
  305.     /* restore the stack */
  306.     xlpopn(6);
  307.  
  308.     /* return the structure name */
  309.     return (structname);
  310. }
  311.  
  312. /* xlrdstruct - convert a list to a structure (used by the reader) */
  313. LVAL xlrdstruct(list)
  314.   LVAL list;
  315. {
  316.     LVAL structname,sym,slotname,expr,last,val;
  317.  
  318.     /* protect the new structure */
  319.     xlsave1(expr);
  320.  
  321.     /* get the structure name */
  322.     if (!consp(list) || !symbolp(car(list)))
  323.     xlerror("bad structure initialization list",list);
  324.     structname = car(list);
  325.     list = cdr(list);
  326.  
  327.     /* enter the MAKE-xxx symbol */
  328.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  329.  
  330.     /* initialize the MAKE-xxx function call expression */
  331.     expr = cons(xlenter(buf),NIL);
  332.     last = expr;
  333.  
  334.     /* turn the rest of the initialization list into keyword arguments */
  335.     while (consp(list) && consp(cdr(list))) {
  336.  
  337.     /* get the slot keyword name */
  338.     slotname = car(list);
  339.     if (!symbolp(slotname))
  340.         xlerror("expecting a slot name",slotname);
  341.     sprintf(buf,":%s",getstring(getpname(slotname)));
  342.  
  343.     /* add the slot keyword */
  344.     rplacd(last,cons(xlenter(buf),NIL));
  345.     last = cdr(last);
  346.     list = cdr(list);
  347.  
  348.     /* add the value expression */
  349.     rplacd(last,cons(car(list),NIL));
  350.     last = cdr(last);
  351.     list = cdr(list);
  352.     }
  353.  
  354.     /* make sure all of the initializers were used */
  355.     if (consp(list))
  356.     xlerror("bad structure initialization list",list);
  357.  
  358.     /* invoke the creation function */
  359.     val = xleval(expr);
  360.  
  361.     /* restore the stack */
  362.     xlpop();
  363.  
  364.     /* return the new structure */
  365.     return (val);
  366. }
  367.  
  368. /* xlprstruct - print a structure (used by printer) */
  369. xlprstruct(fptr,vptr,flag)
  370.   LVAL fptr,vptr; int flag;
  371. {
  372.     LVAL next;
  373.     int i,n;
  374.     xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
  375.     xlprint(fptr,getelement(vptr,0),flag);
  376.     next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
  377.     for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
  378.     if (consp(car(next))) { /* should always succeed */
  379.         xlputc(fptr,' ');
  380.         xlprint(fptr,car(car(next)),flag);
  381.         xlputc(fptr,' ');
  382.         xlprint(fptr,getelement(vptr,i),flag);
  383.     }
  384.     next = cdr(next);
  385.     }
  386.     xlputc(fptr,')');
  387. }
  388.  
  389. /* addslot - make the slot access functions */
  390. LOCAL addslot(slotname,defexpr,slotn,pargs,pbody)
  391.   LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
  392. {
  393.     LVAL sym,args,body,tmp;
  394.     
  395.     /* protect some pointers */
  396.     xlstkcheck(4);
  397.     xlsave(sym);
  398.     xlsave(args);
  399.     xlsave(body);
  400.     xlsave(tmp);
  401.     
  402.     /* construct the update function name */
  403.     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
  404.     sym = xlenter(buf);
  405.     
  406.     /* make the access function */
  407.     args = cons(xlenter("S"),NIL);
  408.     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
  409.     body = cons(xlenter("S"),body);
  410.     body = cons(xlenter("%STRUCT-REF"),body);
  411.     body = cons(body,NIL);
  412.     setfunction(sym,
  413.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  414.  
  415.     /* make the update function */
  416.     args = cons(xlenter("V"),NIL);
  417.     args = cons(xlenter("S"),args);
  418.     body = cons(xlenter("V"),NIL);
  419.     body = cons(cvfixnum((FIXTYPE)slotn),body);
  420.     body = cons(xlenter("S"),body);
  421.     body = cons(xlenter("%STRUCT-SET"),body);
  422.     body = cons(body,NIL);
  423.     xlputprop(sym,
  424.           xlclose(NIL,s_lambda,args,body,NIL,NIL),
  425.           xlenter("*SETF*"));
  426.  
  427.     /* add the slotname to the make-xxx keyword list */
  428.     tmp = cons(defexpr,NIL);
  429.     tmp = cons(slotname,tmp);
  430.     tmp = cons(tmp,NIL);
  431.     if ((args = *pargs) == NIL)
  432.     *pargs = tmp;
  433.     else {
  434.     while (cdr(args) != NIL)
  435.         args = cdr(args);
  436.     rplacd(args,tmp);
  437.     }
  438.     
  439.     /* add the slotname to the %make-xxx argument list */
  440.     tmp = cons(slotname,NIL);
  441.     if ((body = *pbody) == NIL)
  442.     *pbody = tmp;
  443.     else {
  444.     while (cdr(body) != NIL)
  445.         body = cdr(body);
  446.     rplacd(body,tmp);
  447.     }
  448.  
  449.     /* restore the stack */
  450.     xlpopn(4);
  451. }
  452.  
  453. /* updateslot - update a slot definition */
  454. LOCAL updateslot(args,slotname,defexpr)
  455.   LVAL args,slotname,defexpr;
  456. {
  457.     LVAL tmp;
  458.     for (; consp(args); args = cdr(args))
  459.     if (slotname == car(car(args))) {
  460.         if (defexpr != NIL) {
  461.         xlsave1(tmp);
  462.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  463.         setbody(tmp,cons(defexpr,NIL));
  464.         tmp = cons(tmp,NIL);
  465.         defexpr = tmp;
  466.         xlpop();
  467.         }
  468.         rplaca(cdr(car(args)),defexpr);
  469.         break;
  470.     }
  471.     if (args == NIL)
  472.     xlerror("unknown slot name",slotname);
  473. }
  474.